{-# LANGUAGE KindSignatures             #-}
{-# LANGUAGE TypeOperators              #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Orca.Toplevel.Monad
-- Copyright   :  (c) Stephen Tetley 2013
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Toplevel monad wrapping Orca monad, adding environment 
-- acquisition.
--
--------------------------------------------------------------------------------

module Orca.Toplevel.Monad
  where


import Orca.Csound.Monad
import Orca.Csound.Syntax

import Orca.Csound.SignalIO
import Orca.Csound.SignalGenerators



import Control.Applicative

-- Are all components of an algorithm a-rate?
-- If so, typings are greatly simplified...
-- 
-- Actually this doesn\'t matter if we use a record for the
-- registry.





newtype Code ctx a = Code { getCode :: ctx -> Orca a }

instance Functor (Code ctx) where
  fmap f ma = Code $ \ctx -> fmap f $ getCode ma ctx

instance Applicative (Code ctx) where
  pure a    = Code $ \_   -> pure a
  mf <*> ma = Code $ \ctx -> getCode mf ctx <*> getCode ma ctx


instance Monad (Code ctx) where
  return    = pure
  ma >>= k  = Code $ \ctx -> getCode ma ctx >>= \a -> getCode (k a) ctx

liftOrca :: Orca a -> Code ctx a
liftOrca ma = Code $ \_ -> ma

execCode :: ctx -> (Code ctx a) -> [Stmt]
execCode ctx ma = let oma = getCode ma ctx in execOrca oma

-- this is wrong type - only allows 1-in, 1-out port...
-- (note DX7 algorithms are only 1-1)

type SigAugment ctx r1 = SigTrans ctx r1 -> SigTrans ctx r1



newtype Algo reg ctx a = Algo { getAlgo :: reg -> Code ctx a }

instance Functor (Algo reg ctx) where
  fmap f ma = Algo $ \r -> fmap f $ getAlgo ma r

instance Applicative (Algo reg ctx) where
  pure a    = Algo $ \_   -> pure a
  mf <*> ma = Algo $ \r -> getAlgo mf r <*> getAlgo ma r


instance Monad (Algo reg ctx) where
  return    = pure
  ma >>= k  = Algo $ \r -> getAlgo ma r >>= \a -> getAlgo (k a) r


liftSigGen :: SigGen ctx r1 -> Algo reg ctx (Sig r1)
liftSigGen gen = Algo $ \_ -> gen  




operator1 :: (reg -> SigTrans ctx r1) 
          -> (Sig r1 -> SigGen ctx r2)  
          -> Sig r1 
          -> Algo reg ctx (Sig r2)
operator1 fselect1 mf ins1 = Algo $ \r -> 
    let proc1 = fselect1 r 
    in do sig1 <- proc1 ins1 
          sig2 <- mf sig1
          return sig2

apply1 :: (reg -> SigTransRC ctx r1 r2)
       -> Sig r1
       -> Algo reg ctx (Sig r2)
apply1 fselect1 ins1 = Algo $ \r ->
    let proc1 = fselect1 r 
    in proc1 ins1        


operator2 :: (reg -> SigTrans ctx r1) 
          -> (reg -> SigTrans ctx r2) 
          -> (Sig r1 -> Sig r2 -> SigGen ctx r3) 
          -> Sig r1 -> Sig r2
          -> Algo reg ctx (Sig r3)
operator2 fselect1 fselect2 mf ins1 ins2 = Algo $ \r -> 
    let proc1 = fselect1 r 
        proc2 = fselect2 r
    in do sig1 <- proc1 ins1
          sig2 <- proc2 ins2
          sig3 <- mf sig1 sig2
          return sig3




-- RC - rate change


type SigGen     ctx r1    = Code ctx (Sig r1)
type SigTrans   ctx r1    = SigTransRC ctx r1 r1
type SigTransRC ctx r1 r2 = Sig r1 -> Code ctx (Sig r2)
type SigOut     ctx r1    = Sig r1 -> Code ctx ()

out :: SigOut ctx ARate 
out = liftOrca . cs_out


getvar :: (ctx -> a) -> Code ctx a
getvar f = Code $ \ctx -> return $ f ctx

class Get_isine_table ctx where
  isine_table :: ctx -> TableIx

class Get_iduration ctx where
  iduration :: ctx -> IFloat


with_iduration :: Get_iduration ctx => (IFloat -> Code ctx a) -> Code ctx a
with_iduration mf = getvar iduration >>= mf


expseg :: (Get_iduration ctx, KA_Signal rate)
       => (IFloat -> Code ctx (IFloat, [IFloat ::: IFloat]) )
       -> SigGen ctx rate
expseg mf = with_iduration $ \idur -> 
    mf idur >>= \(a,rest) -> liftOrca $ cs_expseg a rest

fmphasor :: Get_isine_table ctx => SigTrans ctx ARate
fmphasor insig = do
    itbl    <- getvar isine_table
    aphs    <- liftOrca $ cs_phasor insig
    asig    <- liftOrca $ cs_tablei_ aphs itbl 1 0 1
    return asig




-- /algorithms/ should be oblivious to Zak ports 

augment :: SigTrans ctx rate -> SigTrans ctx rate -> SigTrans ctx rate
        -> SigTrans ctx rate
augment bef aft proceed = \sig -> bef sig >>= proceed >>= aft
    

before :: SigTrans ctx rate -> SigTrans ctx rate -> SigTrans ctx rate
before bef = augment bef pure

after :: SigTrans ctx rate -> SigTrans ctx rate -> SigTrans ctx rate
after aft = augment pure aft

